Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue66/Construc/Refactor/Source/uRCBuilder.pas

Pascal/Delphi Source File | 2000-11-12 | 17.4 KB | 479 lines

unit uRCBuilder;
interface
uses classes;

const cVersion = 'Version';

type
  tMyBuf = array of byte;
  pMyBuf = ^TmyBuf;

  TResourceHandlerMissingFileNotify = procedure(const filename, info : string) of object;

  TResourceTypeEnum = (reMajor, reMinor, reRelease, reBuild,
                       reProductMajor, reProductMinor, reProductRelease, reProductBuild,
                       reAppid, reDescription, reCompany, reComments, reInternalName, reLegalCopyright,
                       reLegalTrademarks, reProductName, reOriginalFilename, reIconFileName);
  TResourceSettingSourceEnum = (rsEmpty, rsProject, rsFile, rsExecutable);


  TResourceHandler = class(tobject)
  private
    fResourceSource : string;
    fIcondata : pointer;
    flist : tstringlist;
    fOnResourceError : TResourceHandlerMissingFileNotify;
    fRCMAskFilename: string;
    fRCFileName: string;
    fMask : tstringlist;
    fsuccess: boolean;
    function ReadAndTranslateIconFile(var aIconAsString : string) : boolean;
    function getVersionInfo(index: TResourceTypeEnum): string;
    procedure setVersionInfo(index: TResourceTypeEnum;
      const Value: string);
    function getVersionSource(
      Index: TResourceTypeEnum): TResourceSettingSourceEnum;
    procedure setVersionSource(Index: TResourceTypeEnum;
      const Value: TResourceSettingSourceEnum);
    Procedure setVersionInfoAndSource(const WhichOne : TResourceTypeEnum;  const aValue : string; const aSource : TResourceSettingSourceEnum);
    function getResourceName(index: TResourceTypeEnum): string;
    procedure SetBlanksToZero;
    function DoesIconFileExist(var aFileName: string): boolean;
  public
    constructor create(aComponent : tcomponent); //override; overload;
    destructor destroy; override;
    Procedure PrepareResourceData(const TargetFileName, GeneralSettingsFilename : string);
    procedure DoFileError(const fn, info : string);
    Procedure GetSettings(const PathToIni : string; FromWhere : TResourceSettingSourceEnum);
    Procedure SaveSettings(const PathToIni : string; aSection : string = cVersion);
    Procedure ClearSettings;
    procedure WriteRCFile;
    Function DisplayRCData(aTitle : string): string;
    Function VersionSummary: string;
    procedure GetVersionInfoFromProgram(aFilename: string);
    Property RCMaskFileName : string read fRCMaskFileName write fRCMaskFileName;
    Property RCfileName : string read fRCfileName write fRCfileName;
    Property ResourceName[index : TResourceTypeEnum] :  string read getResourceName;
    Property VersionInfo[index : TResourceTypeEnum] : string read getVersionInfo write setVersionInfo;
    Property VersionSource[Index : TResourceTypeEnum] : TResourceSettingSourceEnum read getVersionSource Write setVersionSource;
    Property Success : boolean read fsuccess write fsuccess;
    Property Mask : tstringlist read fMask write fMask;
  published
    Property OnResourceError : TResourceHandlerMissingFileNotify read fOnResourceError write fOnResourceError;
    end;



implementation
uses sysutils, inifiles, typinfo, uVersionInformation;


{ TResourceHandler }

destructor TResourceHandler.destroy;
begin
  if fIconData <> nil
    then freemem(fIconData);
  flist.free;
  fMAsk.free;
  inherited;
end;

function TResourceHandler.DoesIconFileExist(var aFileName : string): boolean;
{ check to see if file as listed in options exists in current dir, otherwise create full path and look for it}
{ Set the current dir to the dir where the .rc file lives first}
begin
  aFileName := VersionInfo[reIconFileName];
  if not FileExists(aFileName)
    then begin
      if not FileExists(IncludeTrailingBackslash(extractFilePath(fRCFileName))+ aFileName)
        then begin
          DoFileError(aFileName, ' Icon File for '+ extractFileName(fRCFileName)+' not found. Will compile without icon.');
          result := false;
          fSuccess := true;
          exit;
          end
        else begin
          aFileName := IncludeTrailingBackslash(extractFilePath(fRCFileName))+aFileName;
          result := true;
          end;
      end
    else begin
      result := true;
      end;
end;

function TResourceHandler.ReadAndTranslateIconFile(var aIconAsString : string) : boolean;
var i  : integer;
    iconFileName, hexline : string;
    MemStream : TMemoryStream;
    p : byte;
begin
  result := true;
  MemStream := TMemoryStream.create;
  try
    result := DoesIconFileExist(IconFileName);
    if not result
      then exit;
    MemStream.LoadFromFile(IconFileName);
    hexline := '';
    aIconAsString := '';
    memstream.Seek(0, soFromBeginning);
    for i := 1 to MemStream.size do begin
      memstream.read(p, 1);
      hexline := hexline + IntToHex(Integer(p), 2)+' ';
      if (i <> 0) and ( (i mod 16) = 0)
        then begin
         setlength(hexline, length(hexline)-1);
         hexline := ''''+hexline+'''';
         aIconAsString := aIconAsString + hexline+#13#10;
         hexline := '';
         end;
      end;
    // pick up the last part of the file if not all lines had 16 bytes
    setlength(hexline, length(hexline)-1);
    hexline := ''''+hexline+'''';
    aIconAsString := aIconAsString + hexline;
    If aIconAsString[length(aIconAsString)-1] = #10
      then setLength(aIconAsString, length(aIconAsString)-2)
      else setLength(aIconAsString, length(aIconAsString));
  finally
    Memstream.free;
  end;
end;


procedure TResourceHandler.WriteRCFile;
var tmp : string;
    tmpsl : tstringlist;
    IconData : string;
    i, MainIconLine : integer;

  Function MakeSureDigitPresent(aString : string): string;
  begin
    if trim(astring) = ''
      then result := '0'
      else result := aString;
  end;


begin
  fSuccess := true;
  Tmpsl := tstringlist.create;
  try
{  if not fileExists(fRCMaskFileName)
    then if assigned(fOnResourceError)
        then begin
           fsuccess := false;
           DoFileError(fRcMaskFileName, 'RC Mask file not found.');
           exit;
           end;
  tmpsl.LoadFromFile(fRCMaskFileName);
  tmp := tmpsl.text;
  }
  if fMask.count = 0
    then if assigned(fOnResourceError)
        then begin
           fsuccess := false;
           DoFileError(fRcMaskFileName, 'Resource Mask empty.');
           exit;
           end;
  tmpsl.assign(fMask);
  tmp := tmpsl.text;
  if ReadAndTranslateIconFile(IconData)
    then tmp := stringReplace(tmp, '#ICONDATA#', IconData, [])
    else begin
      MainIconLine := -1;
      for i := 0 to tmpsl.count-1 do
         if pos('MAINICON', tmpsl[i]) > 0
            then begin
              MainIconLine := i;
              break;
              end;
      if MainIconLine = -1
        then begin
           DoFileError(fRcMaskFileName, 'RC Mask file doesn''t contain MAINICON section.');
           fsuccess := false;
           exit;
           end;
      tmpsl.delete(MainIconLine);
      tmpsl.delete(MainIconLine);
      tmpsl.delete(MainIconLine);
      tmpsl.delete(MainIconLine);
      tmp := tmpsl.text;
      end;
  SetBlanksToZero;
  tmp := stringReplace(tmp, '#Major#', MakeSureDigitPresent(VersionInfo[reMajor]), [rfReplaceAll]);
  tmp := stringReplace(tmp, '#Minor#', MakeSureDigitPresent(VersionInfo[reMinor]), [rfReplaceAll]);
  tmp := stringReplace(tmp, '#Release#', MakeSureDigitPresent(VersionInfo[reRelease]), [rfReplaceAll]);
  tmp := stringReplace(tmp, '#Build#', MakeSureDigitPresent(VersionInfo[reBuild]), [rfReplaceAll]);
  tmp := stringReplace(tmp, '#AppID#', MakeSureDigitPresent(VersionInfo[reAppID]), [rfReplaceAll]);
  tmp := stringReplace(tmp, '#ProductMajor#', MakeSureDigitPresent(VersionInfo[reProductMajor]), [rfReplaceAll]);
  tmp := stringReplace(tmp, '#ProductMinor#', MakeSureDigitPresent(VersionInfo[reProductMinor]), [rfReplaceAll]);
  tmp := stringReplace(tmp, '#ProductRelease#', MakeSureDigitPresent(VersionInfo[reProductRelease]), [rfReplaceAll]);
  tmp := stringReplace(tmp, '#ProductBuild#', MakeSureDigitPresent(VersionInfo[reProductBuild]), [rfReplaceAll]);

  tmp := stringReplace(tmp, '#Company#', VersionInfo[reCompany], [rfReplaceAll]);
  tmp := stringReplace(tmp, '#Description#', VersionInfo[reDescription], [rfReplaceAll]);
  tmp := stringReplace(tmp, '#InternalName#', VersionInfo[reInternalName], [rfReplaceAll]);
  tmp := stringReplace(tmp, '#LegalCopyright#', VersionInfo[reLegalCopyRight], [rfReplaceAll]);
  tmp := stringReplace(tmp, '#LegalTrademarks#', VersionInfo[reLegalTrademarks], [rfReplaceAll]);
  tmp := stringReplace(tmp, '#OriginalFilename#', VersionInfo[reOriginalFilename], [rfReplaceAll]);
  tmp := stringReplace(tmp, '#ProductName#', VersionInfo[reProductName], [rfReplaceAll]);
  tmp := stringReplace(tmp, '#Comments#', VersionInfo[reComments], [rfReplaceAll]);
  tmpsl.text := tmp;
  try
    tmpsl.SaveToFile(fRCFileName);
  except
    on e:exception do begin
      DoFileError(fRCFileName, 'Could not save '+fRCFileName+': '+e.message);
      fsuccess := false;
      end;
  end;
  finally
    tmpsl.free;
  end;
end;


//DONE: when reading settings, set object to tResourceSettingSourceEnum
procedure TResourceHandler.GetSettings(const PathToIni : string; FromWhere : TResourceSettingSourceEnum);
var i : TResourceTypeEnum;
begin
  if FileExists(PathToIni)
    then with tinifile.create(PathToIni) do begin
      fResourceSource := filename;
      for i := low(i) to high(i) do
        if (VersionInfo[i] = '0') or (VersionInfo[i] = '')
          then SetVersionInfoAndSource(i, readString(cVersion, ResourceName[i], VersionInfo[i]), FromWhere);
      UpdateFile;
      free;
      end
    else If (FromWhere = rsFile)
       then begin
         DoFileError(PathToIni, 'Did not exist, trying to read version info from .exe');
         fResourceSource := 'From Executable';
         try
           GetVersionInfoFromProgram(ChangeFileExt(PathToIni, '.exe'));
         except
           on e:exception do begin
           DoFileError(ChangeFileExt(PathToIni, '.exe'), 'Unable to read version info from exe, '+e.message);
           end;
         end;
         end;
end;

procedure TResourceHandler.ClearSettings;
var i : TResourceTypeEnum;
begin
  flist.Clear;
  for i := reMajor to reAppid do
     flist.addobject('0', tobject(rsEmpty));
  for i := reDescription to reIconFileName do
     flist.addobject('', tobject(rsEmpty));
end;

procedure TResourceHandler.SaveSettings(const PathToIni: string; aSection : string = cVersion);
var i : TResourceTypeEnum;
begin
  try
  with tinifile.create(PathToIni) do begin
     for i := low(i) to high(i) do
       WriteString(aSection, ResourceName[i], VersionInfo[i]);
     UpdateFile;
     free;
     end;
  except
    on e:exception do begin
      DoFileError('Problem saving '+PathToIni, e.message);
      end;
    end;

end;


function TResourceHandler.DisplayRCData(aTitle : string): string;
var i : TResourceTypeEnum;
begin
  Result := aTitle+ #13#10; //'RC settings from '+fResourceSource + #13#10;
  Result := Result + 'FileVersion = ' + VersionInfo[reMajor]+'.'+VersionInfo[reMinor]+'.'+VersionInfo[reRelease]+'.'+VersionInfo[reBuild]+#13#10;
  Result := Result + 'ProductVersion = ' + VersionInfo[reProductMajor]+'.'+VersionInfo[reProductMinor]+'.'+VersionInfo[reProductRelease]+'.'+VersionInfo[reProductBuild]+#13#10;
  for i := reAppid to reIconFileName do
    result := result + ResourceName[i]+' = ' + VersionInfo[i]+#13#10;
end;

constructor TResourceHandler.create(aComponent: tcomponent);
var i : TResourceTypeEnum;
begin
//  inherited;
  flist := tstringlist.create;
  fMask := tstringlist.create;
  for i := low(i) to high(i) do
    flist.add('');
end;

function TResourceHandler.getVersionInfo(
  index: TResourceTypeEnum): string;
begin
  result := flist[ord(index)];
  if (result = '')
      and
     ( (index = reBuild)
        or
       (index = reProductBuild))
    then result := '0';
end;

procedure TResourceHandler.setVersionInfo(index: TResourceTypeEnum;
  const Value: string);
begin
 flist[ord(index)] := value;
end;

function TResourceHandler.getVersionSource(
  Index: TResourceTypeEnum): TResourceSettingSourceEnum;
begin
  result := TResourceSettingSourceEnum(flist.objects[ord(index)]);
end;

procedure TResourceHandler.setVersionSource(Index: TResourceTypeEnum;
  const Value: TResourceSettingSourceEnum);
begin
  flist.objects[ord(index)] := tobject(ord(value));
end;


procedure TResourceHandler.setVersionInfoAndSource(
  const WhichOne: TResourceTypeEnum; const aValue: string;
  const aSource: TResourceSettingSourceEnum);
begin
  setVersionInfo(WhichOne, aValue);
  setVersionSource(WhichOne, aSource);

end;

function TResourceHandler.getResourceName(index: TResourceTypeEnum): string;
var  EnumType : PTypeInfo;
begin
  EnumType := TypeInfo(TResourceTypeEnum);
  result := GetEnumName(EnumType, ord(index) );
  system.delete(result, 1, 2);
end;

Procedure TResourceHandler.GetVersionInfoFromProgram(aFilename : string);
  function getNthNumber(n : integer; const tmp : string): string;
  var i, startpos : integer;
      found : boolean;
  begin
    result := tmp;
    case n of
      1 : begin
           system.delete(result, pos('.', result),100);
           end;
      2 : begin
            startpos := 1;
            for i := 1 to length(tmp) do
              if tmp[i] = '.'
                then begin
                  startpos := i;
                  break;
                  end;
            system.delete(result, 1, startpos);
            system.delete(result, pos('.', result),100);
            end;
      3 : begin
            found := false;
            startpos := 1;
            for i := 1 to length(tmp) do begin
              if not found and (tmp[i] = '.')
                then begin
                  found := true;
                  continue;
                  end;
              if found and (tmp[i] = '.')
                then begin
                   startpos := i;
                   break;
                   end;
              end;
            system.delete(result, 1, startpos);
            system.delete(result, pos('.', result),100);
            end;
      4 : begin
            startpos := 1;
            for i := length(tmp) downto 1 do
            if tmp[i] = '.'
              then begin
                startpos := i;
                break;
                end;
            system.delete(result, 1, startpos);
            end;
      end; // case
   end;

begin
  with TVersionInformation.instance do begin
    FileName := aFileName;
    if HasVerInfo
      then begin
        setVersionInfoAndSource(reMajor, getNthNumber(1, Values[MSVerNames[msFileVersion]]), rsExecutable);
        setVersionInfoAndSource(reMinor, getNthNumber(2, Values[MSVerNames[msFileVersion]]), rsExecutable);
        setVersionInfoAndSource(reRelease, getNthNumber(3, Values[MSVerNames[msFileVersion]]), rsExecutable);
        setVersionInfoAndSource(reBuild, getNthNumber(4, Values[MSVerNames[msFileVersion]]), rsExecutable);
        setVersionInfoAndSource(reProductMajor, getNthNumber(1, Values[MSVerNames[msProductVersion]]), rsExecutable);
        setVersionInfoAndSource(reProductMinor, getNthNumber(2, Values[MSVerNames[msProductVersion]]), rsExecutable);
        setVersionInfoAndSource(reProductRelease, getNthNumber(3, Values[MSVerNames[msProductVersion]]), rsExecutable);
        setVersionInfoAndSource(reProductBuild, getNthNumber(4, Values[MSVerNames[msProductVersion]]), rsExecutable);
        setVersionInfoAndSource(reAppID,'AppID', rsExecutable);

        setVersionInfoAndSource(reCompany, Values[MSVerNames[msCompanyName]], rsExecutable);
        setVersionInfoAndSource(reDescription, Values[MSVerNames[msFileDescription]], rsExecutable);
        setVersionInfoAndSource(reInternalName, Values[MSVerNames[msInternalName]], rsExecutable);
        setVersionInfoAndSource(reLegalCopyRight, Values[MSVerNames[msLegalCopyRight]], rsExecutable);
        setVersionInfoAndSource(reLegalTrademarks, Values[MSVerNames[msLegalTrademarks]], rsExecutable);
        setVersionInfoAndSource(reOriginalFileName, Values[MSVerNames[msOriginalFileName]], rsExecutable);
        setVersionInfoAndSource(reProductName, Values[MSVerNames[msProductName]], rsExecutable);
        setVersionInfoAndSource(reComments, Values[MSVerNames[msComments]], rsExecutable);
        end
      else begin
        DoFileError(aFileName, ErrorMessage);
        end;
    end;
end;



procedure TResourceHandler.SetBlanksToZero;
var i : TResourceTypeEnum;
begin
  for i := reMajor to reAppid do
    if flist[ord(i)] = '0'
      then flist[ord(i)] := '0';
end;

procedure TResourceHandler.DoFileError(const fn, info: string);
begin
  if assigned(fOnResourceError)
    then fOnResourceError(fn, info);
end;

procedure TResourceHandler.PrepareResourceData(const TargetFileName,
  GeneralSettingsFilename: string);
begin
  ClearSettings;
  GetSettings(GeneralSettingsFilename, rsProject);
  GetSettings(TargetFileName, rsFile);
end;

function TResourceHandler.VersionSummary: string;
var i : TResourceTypeEnum;
begin
  Result := 'VerInfo: ' + VersionInfo[reMajor]+'.'+VersionInfo[reMinor]+'.'+VersionInfo[reRelease]+'.'+VersionInfo[reBuild]+'; '+
             VersionInfo[reProductMajor]+'.'+VersionInfo[reProductMinor]+'.'+VersionInfo[reProductRelease]+'.'+VersionInfo[reProductBuild]+'; ';
  for i := reAppid to reOriginalFilename do
    result := result + VersionInfo[i]+'; ';
end;

end.